Delphi Magazine Collection 2001/Delphi Magazine Collection 20001 (2001).iso/DISKS/Issue50/Except/LIUTILS.PAS

Pascal/Delphi Source File | 1999-09-03 | 8.4 KB | 366 lines

unit LIUtils;

interface

const
  xorMask               = $AA;
  escMask               = $3F;
  escLineShift          = 6;
  escByteLineByteOfs    = $3F;
  escWordLineWordOfs    = $3E;
  escWordLineDWordOfs   = $3C;
  escFileName           = $3B;
  escFirst              = $3B;

type
  PByte     = ^Byte;
  PShortInt = ^ShortInt;
  PWord     = ^Word;
  PSmallInt = ^SmallInt;
  PDWord    = ^Longint;
  PLongint  = ^Longint;

  PRTLIHeader = ^TRTLIHeader;
  TRTLIHeader = record
    rtliUnitCount: Integer;
    rtliPublicCount: Integer;
    rtliLineCount: Integer;
    rtliFixup: Integer;
  end;

  TGrowingArray = class
  protected
    FArrPtr:      Pointer;
    FCurPtr:      Pointer;
    FElementSize: Integer;
    FLimit:       Integer;
    FCount:       Integer;
    FDelta:       Integer;
    procedure SetLimit(NewLimit: Integer);
    function GetItem(Index: Integer): Pointer;
  public
    constructor Create(ALimit,ADelta,AElementSize: Integer);
    destructor Destroy; override;
    function Add: Pointer;
    function Allocate(No: Integer): Pointer;
    property Items[Index: Integer]: Pointer read GetItem; default;
    property ArrPtr: Pointer read FArrPtr;
    property Count: Integer read FCount;
    property Limit: Integer read FLimit write SetLimit;
    property ElementSize: Integer read FElementSize;
    property Delta: Integer read FDelta;
  end;

function EncodeString(const S: String; Buffer: PChar): Integer;
function DecodeString(var S: String; P: PChar): PChar;
function EncodeSymbolOfs(Buffer: PChar; OfsDelta: Integer): Integer;
function DecodeSymbolOfs(Buffer: PChar; var Ofs: Integer): PChar;
function EncodeLineNumber(Buffer: PChar; LineDelta, OfsDelta: Integer): Integer;
function DecodeLineNumber(Buffer: PChar; var LineDelta,OfsDelta: Integer; var FileName: String): PChar;

function ParseHex(const S: String; var Index: Integer): Longint;
function ParseDec(const S: String; var Index: Integer): Longint;
function ParseStr(const S: String; var Index: Integer): String;
function ParseChr(const S: String; var Index: Integer): Char;
procedure SkipBlanks(const S: String; var Index: Integer);

implementation

constructor TGrowingArray.Create(ALimit,ADelta,AElementSize: Integer);
begin
  FElementSize := AElementSize;
  FLimit := ALimit;
  FDelta := ADelta;
  GetMem(FArrPtr, Limit * ElementSize);
  FCurPtr := FArrPtr;
end;

destructor TGrowingArray.Destroy;
begin
  FreeMem(FArrPtr, FLimit * FElementSize);
  inherited Destroy;
end;

function TGrowingArray.Add: Pointer;
begin
  if Count = Limit then
    Limit := Limit + Delta;
  Result := FCurPtr;
  Inc(PChar(FCurPtr), FElementSize);
  Inc(FCount);
end;

function TGrowingArray.Allocate(No: Integer): Pointer;
begin
  if Count + No >= Limit then
    Limit := Count + No + Delta;
  Result := FCurPtr;
  if FElementSize = 1 then
    Inc(PChar(FCurPtr), No)     // Do not use multiplication
  else
    Inc(PChar(FCurPtr), FElementSize * No);
  Inc(FCount, No);
end;

procedure TGrowingArray.SetLimit(NewLimit: Integer);
var
  Allocated: Integer;
begin
  Allocated := PChar(FCurPtr) - PChar(FArrPtr);
  ReallocMem(FArrPtr, NewLimit * ElementSize);
  FLimit := NewLimit;
  FCurPtr := PChar(FArrPtr) + Allocated;
end;

function TGrowingArray.GetItem(Index: Integer): Pointer;
begin
  Result := PChar(FArrPtr) + Index * ElementSize;
end;

function EncodeString(const S: String; Buffer: PChar): Integer;
var
  I: Integer;
  P: PChar;
begin
  P := Buffer;
  PByte(P)^ := Length(S);
  Inc(P);
  I := 0;
  while I < Length(S) do
  begin
    Inc(I);
    P^ := Chr(Ord(S[I]) xor (xorMask + I));
    Inc(P);
  end;
  Result := P - Buffer;
end;

function DecodeString(var S: String; P: PChar): PChar;
var
  I: Integer;
begin
  SetString(S, nil, Ord(P^));
  Inc(P);
  I := 0;
  while I < Length(S) do
  begin
    Inc(I);
    S[I] := Chr(Ord(P^) xor (xorMask + I));
    Inc(P);
  end;
  Result := P;
end;

function EncodeSymbolOfs(Buffer: PChar; OfsDelta: Integer): Integer;
var
  P: PChar;
begin
  P := Buffer;
  if OfsDelta <= 127 then
    begin
      PByte(P)^ := OfsDelta;
      Inc(P);
    end
  else
    if OfsDelta < 32767 then
      begin
        PWord(P)^ := Lo(OfsDelta) shl 8 + Hi(OfsDelta) + $80;
        Inc(P, 2);
      end
    else
      begin
        PWord(P)^ := $FFFF;
        Inc(P, 2);
        PDWord(P)^ := OfsDelta;
        Inc(P, 4);
      end;
  Result := P - Buffer;
end;

function DecodeSymbolOfs(Buffer: PChar; var Ofs: Integer): PChar;
var
  P: PChar;
begin
  P := Buffer;
  if PByte(P)^ <= 127 then
    begin
      Ofs := PByte(P)^;
      Inc(P);
    end
  else
    if PWord(P)^ <> $FFFF then
      begin
        Ofs := PByte(P+1)^ + (PByte(P)^ and $7F) shl 8;
        Inc(P, 2);
      end
    else
      begin
        Inc(P, 2);
        Ofs := PDWord(P)^;
        Inc(P, 4);
      end;
  Result := P;
end;

function EncodeLineNumber(Buffer: PChar; LineDelta, OfsDelta: Integer): Integer;
var
  P: PChar;
begin
  P := Buffer;
  if (LineDelta >= 1) and (LineDelta <= 4) and
    (OfsDelta > 0) and (OfsDelta <= escFirst) then
    begin
      PByte(P)^ := (LineDelta - 1) shl escLineShift + OfsDelta - 1;
      Inc(P);
    end
  else
    if (LineDelta <= 127) and (LineDelta >= -128) and
      (OfsDelta <= 127) and (OfsDelta >= -128) then
      begin
        PByte(P)^ := escByteLineByteOfs;
        Inc(P);
        PByte(P)^ := LineDelta;
        Inc(P);
        PByte(P)^ := OfsDelta;
        Inc(P);
      end
    else
      if (LineDelta <= 32767) and (LineDelta >= -32768) and
        (OfsDelta <= 32767) and (OfsDelta >= -32768) then
        begin
          PByte(P)^ := escWordLineWordOfs;
          Inc(P);
          PWord(P)^ := LineDelta;
          Inc(P, 2);
          PWord(P)^ := OfsDelta;
          Inc(P, 2);
        end
      else
        begin
          PByte(P)^ := escWordLineDWordOfs;
          Inc(P);
          PWord(P)^ := LineDelta;
          Inc(P, 2);
          PDWord(P)^ := OfsDelta;
          Inc(P, 4);
        end;
  Result := P - Buffer;
end;

function DecodeLineNumber(Buffer: PChar; var LineDelta,OfsDelta: Integer; var FileName: String): PChar;
var
  P: PChar;
begin
  P := Buffer;
  case Ord(P^) and escMask of
    escFileName:
      begin
        Inc(P);
        P := DecodeString(FileName, P);
        LineDelta := MaxInt;
      end;
    escByteLineByteOfs:
      begin
        Inc(P);
        LineDelta := PShortInt(P)^;
        Inc(P);
        OfsDelta := PShortInt(P)^;
        Inc(P);
      end;
    escWordLineWordOfs:
      begin
        Inc(P);
        LineDelta := PSmallInt(P)^;
        Inc(P, 2);
        OfsDelta := PSmallInt(P)^;
        Inc(P, 2);
      end;
    escWordLineDWordOfs:
      begin
        Inc(P);
        LineDelta := PSmallInt(P)^;
        Inc(P, 2);
        OfsDelta := PLongint(P)^;
        Inc(P, 4);
      end;
    else
      LineDelta := (Ord(P^) shr escLineShift) + 1;
      OfsDelta  := (Ord(P^) and escMask) + 1;
      Inc(P);
  end;
  Result := P;
end;

function ParseHex(const S: String; var Index: Integer): Longint;
var
  C: Char;
  I: Integer;
begin
  Result := -1;
  I:=0;
  while Index <= Length(S) do
  begin
    C := S[Index];
    case C of
      '0'..'9': I := Ord(C) - Ord('0');
      'A'..'F': I := Ord(C) - (Ord('A') - 10);
      else Exit;
    end;
    if Result = -1 then
      Result := I
    else
      Result := Result shl 4 + I;
    Inc(Index);
  end;
end;

function ParseDec(const S: String; var Index: Integer): Longint;
var
  C: Char;
  I: Integer;
begin
  Result := -1;
  I:=0;
  while Index <= Length(S) do
  begin
    C := S[Index];
    case C of
      '0'..'9': I := Ord(C) - Ord('0');
      else Exit;
    end;
    if Result = -1 then
      Result := I
    else
      Result := Result * 10 + I;
    Inc(Index);
  end;
end;

function ParseStr(const S: String; var Index: Integer): String;
begin
  Result := '';
  while (Index <= Length(S)) and not (S[Index] in [#9, ' ', '(', ')']) do
  begin
    Result := Result + S[Index];
    Inc(Index);
  end;
end;

function ParseChr(const S: String; var Index: Integer): Char;
begin
  Result := #0;
  if Index <= Length(S) then
  begin
    Result := S[Index];
    Inc(Index);
  end;
end;

procedure SkipBlanks(const S: String; var Index: Integer);
begin
  while (Index <= Length(S)) and (S[Index] in [#9, ' ']) do
    Inc(Index);
end;

end.